Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume10/xlisp21/part02

Text File | 1990-02-26 | 73.0 KB | 2,591 lines

Newsgroups: comp.sources.misc
organization: Cognos Inc., Ottawa, Canada
subject: v10i089: XLisP 2.1 sources 1b (2/3) / 5
From: [e-mail] (Gary Murphy)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 89
Submitted-by: [e-mail] (Gary Murphy)
Archive-name: xlisp21/part02

#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    xl-001.bug
#    xl-002.bug
#    xl-003.bug
#    xl-004.bug
#    xl-005.bug
#    xl-006.bug
#    xl-cl001.fix
#    xl-xs001.bug
# This archive created: Sun Feb 18 23:28:59 1990
# By:    Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xl-001.bug'" '(4674 characters)'
if test -f 'xl-001.bug'
then
    echo shar: over-writing existing file "'xl-001.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-001.bug'
XFrom sce!mitel!uunet!cs.utexas.edu!tut.cis.ohio-state.edu!ucbvax!hplabs!hplabsz!mayer Thu Jun 22 07:40:45 EDT 1989
XArticle: 118 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!cs.utexas.edu!tut.cis.ohio-state.edu!ucbvax!hplabs!hplabsz!mayer
XFrom: [e-mail] (Niels Mayer)
XNewsgroups: comp.lang.lisp.x
XSubject: Re: XLISP 2.0 -- bug in stream implementation // XLISP internals Docs?
XMessage-ID: <[e-mail]>
XDate: 14 Jun 89 05:10:28 GMT
XReferences: <[e-mail]>
XReply-To: [e-mail] (Niels Mayer)
XOrganization: Hewlett-Packard Labs, Software Technology Lab, Palo Alto, CA.
XLines: 41
XSummary:
XExpires:
XSender:
XFollowup-To:
X
XIn article <[e-mail]> [e-mail] (Niels Mayer) writes:
X>It looks like garbage collection is trashing a pointer somewhere when using
X>make-string-input-stream running read-char on that stream. After doing a
X>bunch of read-chars on that stream, I get an "error: bad stream" message.
X>This happens more often right after you start up xlisp, and less frequently
X>upon subsequent garbage collections.
X
XSomeone inside HP kindly mailed me an archive of the last year of
Xcomp.lang.lisp.x, and inside that archive, I found the following fix:
X
X     Note 58       two bugs with unnamed streams in xlisp 2.0
X     [e-mail] (Paul A.W. van Niekerk)   7:13 am  Dec 16, 1988
X
X     I discovered two bugs in my copy of xlisp 2.0 concerning unnamed streams.
X     The bugs + fixes follow.
X
X     1. Unnamed streams never survive a garbage collection.
X        Fix: in xldmem.c change in function mark the line:
X           if ((type = ntype(this)) == CONS) {
X        to
X           if ((type = ntype(this)) == CONS || type == USTREAM) {
X
X     2. (format nil ...) does not protect the unnamed stream it creates, it will
X        vanish during a GC.
X        Fix: in xlfio.c add to function xformat the lines:
X           xlsave1(val);
X           ...
X           xlpop();
X
X     Now USTREAMS seem to work fine.
X     Paul van Niekerk.
X     --
X     Paul A.W. van Niekerk                 |  All standard
X     Delft University of Technology        |  disclaimers apply ...
X
X-------------------------------------------------------------------------------
X        Niels Mayer -- hplabs!mayer -- [e-mail]
X          Human-Computer Interaction Department
X               Hewlett-Packard Laboratories
X                  Palo Alto, CA.
X                   *
X
X
XFrom sce!mitel!uunet!cs.utexas.edu!csd4.milw.wisc.edu!dogie.macc.wisc.edu!indri!nero!blake!uw-beaver!tektronix!tekcrl!tekgvs!toma Thu Jun 22 07:41:11 EDT 1989
XArticle: 119 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!cs.utexas.edu!csd4.milw.wisc.edu!dogie.macc.wisc.edu!indri!nero!blake!uw-beaver!tektronix!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: Re: XLISP 2.0 -- bug in stream implementation // XLISP internals Docs?
XMessage-ID: <[e-mail]>
XDate: 14 Jun 89 14:41:38 GMT
XReferences: <[e-mail]>
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 39
X
XIn article <[e-mail]> [e-mail] (Niels Mayer) writes:
X>It looks like garbage collection is trashing a pointer somewhere when using
X>make-string-input-stream running read-char on that stream. A[...]
X
X>I'm going to try to track this down in the code, but I thought I'd tap your
X>collective wisdoms on this problem. Maybe someone's already fixed it?  [...]
X
XYes the fix has been posted.  An abridged copy is appended to this posting.
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X----------------------- OLD POSTING FOLLOWS --------------------------
X
XFrom: [e-mail] (Paul A.W. van Niekerk)
XNewsgroups: comp.lang.lisp.x
XSubject: two bugs with unnamed streams in xlisp 2.0
XDate: 16 Dec 88 15:13:26 GMT
XOrganization: DELFT UNIVERSITY OF TECHNOLOGY
X              Faculty of Electrical Engineering
X              Computer architecture and Digital Technique
X              Mekelweg 4   -   2628 CD  Delft
X
XI discovered two bugs in my copy of xlisp 2.0 concerning unnamed streams.
XThe bugs + fixes follow.
X
X1. Unnamed streams never survive a garbage collection.
X   Fix: in xldmem.c change in function mark the line:
X    if ((type = ntype(this)) == CONS) {
X   to
X    if ((type = ntype(this)) == CONS || type == USTREAM) {
X
X2. (format nil ...) does not protect the unnamed stream it creates, it will
X   vanish during a GC.
X   Fix: in xlfio.c add to function xformat the lines:
X    xlsave1(val);
X    ...
X    xlpop();
X
XNOTES: xlsave1(val) is being passed an uninitialized value! where do the
X       above xlsave1/xlpop go? pop before return?
SHAR_EOF
if test 4674 -ne "`wc -c 'xl-001.bug'`"
then
    echo shar: error transmitting "'xl-001.bug'" '(should have been 4674 characters)'
fi
echo shar: extracting "'xl-002.bug'" '(8590 characters)'
if test -f 'xl-002.bug'
then
    echo shar: over-writing existing file "'xl-002.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-002.bug'
XFrom sce!mitel!uunet!cs.utexas.edu!tut.cis.ohio-state.edu!unmvax!ogccse!blake!uw-beaver!tektronix!zephyr.ens.tek.com!tekcrl!tekgvs!toma Tue Aug 29 08:42:34 EDT 1989
XArticle: 139 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!cs.utexas.edu!tut.cis.ohio-state.edu!unmvax!ogccse!blake!uw-beaver!tektronix!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: Some Xlisp 2.0 read/print bugs
XMessage-ID: <[e-mail]>
XDate: 24 Aug 89 15:44:30 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 262
XPosted: Thu Aug 24 08:44:30 1989
X
XI discovered these problems with characters, strings, and symbols while
Xworking on some Common Lisp-like enhancements.
X
X(I will post the enhancements when finished.  These include COERCE,
XCONCATENATE, and enhancements to functions that CL states take sequence
Xarguments (lists, arrays, or strings in XLISP case) which XLISP implements
Xtypically only for lists (except for SUBSEQ which only works on strings).
X
X
XProblem: Uninterned symbols do not print with leading #:
XExample: (GENSYM)
XFix:
X
X1) At the beginning of xlprint, replace the code to print NIL with:
X
X    /* print nil */
X    if (vptr == NIL) {
X        xlputstr(fptr,
X            (((!flag) || (getvalue(s_printcase) != k_downcase))?"NIL":"nil"));
X        return;
X    }
X
X2) In putsymbol, add these declarations:
X
X    int i;
X    LVAL sym,array;
X
X3> In putsymbol, add the following *after* the code section titled "check
X   for printing without escapes":
X
X    /* check for uninterned symbol */
X    i = hash(str,HSIZE);
X    array = getvalue(obarray);
X    for (sym = getelement(array,i);sym; sym = cdr(sym))
X        if (strcmp(str,(char*)getstring(getpname(car(sym)))) == 0)
X            goto internedSymbol;
X
X    xlputc(fptr,'#');   /* indicate uninterned */
X    xlputc(fptr,':');
X
XinternedSymbol:         /* sorry about the "goto" */
X
X
X*******************************************************************
X
XProblem: strings containing nulls cannot be read or printed.
X(Note, strcat has the same problem, but I have a new version, the
X Common Lisp CONCATENATE function, which will replace it.
X
X
XExample: Enter "A string\000will forget these"
X
XFix:
X
X1) In rmdquote change section "check for buffer overflow" to:
X
X    if (blen >= STRMAX) {
X        newstr = newstring(len + STRMAX + 1);
X        sptr = getstring(newstr);
X        if (str) memcpy((char *)sptr,(char *)getstring(str),len);
X        *p = '\0';
X        memcpy((char *)sptr+len,(char *)buf,blen+1);
X        p = buf;
X        blen = 0;
X        len += STRMAX;
X        str = newstr;
X    }
X
X2) In rmdquote, change section "append the last substring" to:
X
X    if (str == NIL || blen) {
X        newstr = newstring(len + blen + 1);
X        sptr = getstring(newstr);
X        if (str) memcpy((char *)sptr,(char *)getstring(str),len);
X        *p = '\0';
X        memcpy((char *)sptr+len,(char *)buf,blen+1);
X        str = newstr;
X    }
X
X3) New versions of putstring and putqstring
X
X
X/* putstring - output a string */
X/* rewritten to  print strings containing nulls TAA mod*/
XLOCAL VOID putstring(fptr,str)
X  LVAL fptr,str;
X{
X    unsigned char* p = getstring(str);
X    int len = getslength(str) - 1;
X
X    /* output each character */
X    while (len-- > 0) xlputc(fptr,*p++);
X}
X
X/* putqstring - output a quoted string */
X/* rewritten to  print strings containing nulls TAA mod*/
XLOCAL VOID putqstring(fptr,str)
X  LVAL fptr,str;
X{
X    unsigned char* p = getstring(str);
X    int len = getslength(str) - 1;
X    int ch;
X
X    /* output the initial quote */
X    xlputc(fptr,'"');
X
X    /* output each character in the string */
X    while (len-- > 0) {
X        ch = *p++;
X
X        /* check for a control character */
X        if (ch < 040 || ch == '\\' || ch > 0176) {
X            xlputc(fptr,'\\');
X            switch (ch) {
X                case '\011':
X                    xlputc(fptr,'t');
X                    break;
X                case '\012':
X                    xlputc(fptr,'n');
X                    break;
X                case '\014':
X                    xlputc(fptr,'f');
X                    break;
X                case '\015':
X                    xlputc(fptr,'r');
X                    break;
X                case '\\':
X                    xlputc(fptr,'\\');
X                    break;
X                default:
X                    putoct(fptr,ch);
X                    break;
X            }
X        }
X
X        /* output a normal character */
X        else
X            xlputc(fptr,ch);
X    }
X
X
X    /* output the terminating quote */
X    xlputc(fptr,'"');
X}
X
X
X********************************************
X
XProblem: Control and meta characters print "raw" with prin1.
X
XExample: Execute (int-char 7)
X
XFix: New version of putchcode:
X
X/* putchcode - output a character */
X/* modified to print control and meta characters TAA Mod */
X/* Format: #\[M-][C-]c
X   Where "M-" denotes character is meta character (value > 127).
X         "C-" denotes character is control character ( value modulo 128 < 32)
X   and "c" is either a printing character or "Space", "Newline", or "Rubout".
X*/
X
X
XLOCAL VOID putchcode(fptr,ch,escflag)
X  LVAL fptr; int ch,escflag;
X{
X    if (escflag) {
X        xlputstr(fptr,"#\\");
X        if (ch > 127) {
X            ch -= 128;
X            xlputstr(fptr,"M-");
X        }
X        switch (ch) {
X            case '\n':
X                xlputstr(fptr,"Newline");
X                break;
X            case ' ':
X                xlputstr(fptr,"Space");
X                break;
X            case 127:
X                xlputstr(fptr,"Rubout");
X                break;
X            default:
X                if (ch < 32) {
X                    ch += '@';
X                    xlputstr(fptr,"C-");
X                }
X                xlputc(fptr,ch);
X                break;
X        }
X    }
X    else xlputc(fptr,ch);
X}
X
X*******************************************
X
XProblem: Inability to declare character literals for control and meta
X characters.
X
XFix: in rmhash(), first add declaration "int i", then
X     change case '\\' code to:
X
X    case '\\':
X        for (i = 0; i < STRMAX-1; i++) {
X            if ((tentry(buf[i] = checkeof(fptr))  != k_const) &&
X                buf[i] != '\\' && buf[i] != '|') {
X                xlungetc(fptr, buf[i]);
X                break;
X            }
X        }
X        buf[i] = 0;
X
X        ch = buf[0];
X        if (strlen(buf) > 1) {
X            upcase(buf);
X            bufp = &buf[0];
X            ch = 0;
X            if (strncmp(bufp,"M-",2) == 0) {
X                ch = 128;
X                bufp += 2;
X            }
X            if (strcmp(bufp,"NEWLINE") == 0)
X                ch += '\n';
X            else if (strcmp(bufp,"SPACE") == 0)
X                ch += ' ';
X            else if (strcmp(bufp,"RUBOUT") == 0)
X                ch += 127;
X            else if (strlen(bufp) == 1)
X                ch += *bufp;
X            else if (strncmp(bufp,"C-",2) == 0 && strlen(bufp) == 3)
X                ch += bufp[2] & 31;
X            else xlerror("unknown character name",cvstring(buf));
X        }
X        rplaca(val,cvchar(ch));
X        break;
X
X***********************************************
X
XProblem: Invalid symbols can be created with intern and make-symbol.
X    Also, you can make NIL, which is highly irregular.
X
XExample: (intern "abc\017def")  (intern "NIL")
X
X
XFix: Add to makesymbol(), before section "make the symbol":
X
X    /* check for making "NIL" -- very bad */
X    if (strcmp((char *)getstring(pname),"NIL") == 0)
X        xlerror("you've got to be kidding!");
X
X    /* check for containing only printable characters */
X    i = getslength(pname)-1;
X    while (i-- > 0) if (((signed char)(pname->n_string[i])) < 32 )
X        xlerror("string contains non-printing characters",pname);
X
X
X
X*****************
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Tue Aug 29 11:30:44 EDT 1989
XArticle: 140 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: Yet Another XLISP Bug
XMessage-ID: <[e-mail]>
XDate: 25 Aug 89 14:37:30 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 13
X
X
XProblem: Functions NTH and NTHCDR give errors when applied to zero length
X     lists.
X
XExample: (NTH 1 '())
X
XFix: In function nth(), replace call of xlgacons() with xlgalist()
X
X(That was simple, wasn't it?)
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X
SHAR_EOF
if test 8590 -ne "`wc -c 'xl-002.bug'`"
then
    echo shar: error transmitting "'xl-002.bug'" '(should have been 8590 characters)'
fi
echo shar: extracting "'xl-003.bug'" '(3526 characters)'
if test -f 'xl-003.bug'
then
    echo shar: over-writing existing file "'xl-003.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-003.bug'
XFrom sce!mitel!uunet!cs.utexas.edu!tut.cis.ohio-state.edu!ucbvax!hplabs!hplabsz!mayer Fri Sep  1 08:29:10 EDT 1989
XArticle: 141 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!cs.utexas.edu!tut.cis.ohio-state.edu!ucbvax!hplabs!hplabsz!mayer
XFrom: [e-mail] (Niels Mayer)
XNewsgroups: comp.lang.lisp.x,comp.lang.lisp
XSubject: Bug+Fix for xlisp2.0 method definition <-> Question: Should "defmethod" and "defmacro" use lexical scoping
XMessage-ID: <[e-mail]>
XDate: 26 Aug 89 13:37:22 GMT
XReply-To: [e-mail] (Niels Mayer)
XOrganization: Hewlett-Packard Labs, Software Technology Lab, Palo Alto, CA.
XLines: 83
XXref: cognos comp.lang.lisp.x:141 comp.lang.lisp:1787
XSummary:
XExpires:
XSender:
XFollowup-To:
X
XIn looking over the xlisp 2.0 objects code, I found a problem in
Xxlobj.c:clanswer() in which I noticed that the :answer method on class
XClass does not save the lexical (xlenv) and functional (xlfenv)
Xenvironments in the closure created by xlclose() during method definition.
XThus, when the method gets evaluated, you get unbound symbol/function
Xerrors because the environment of the method call doesn't contain the
Xbindings present in the definition's environment.  [For you non xlispers
Xout there, :answer defines a method on a class (essentially, a
X"defmethod").]
X
XBefore I commit to my fix, I wanted to ask you all whether there is a good
Xreason for NOT using the lexical and functional environment of a call to
X"defmethod" during a method evaluation.
X
XI would expect that you'd want to use lexical scoping for defining methods
Xjust like you would for defuns and lambdas. But I've been surprised before.
X
XAnother case in which xlclose() isn't passed xlenv and xlfenv is in
Xxlcont.c:xdefmacro(). Is there a reason why you wouldn't want to pass
Xin the lexical environment of a call to defmacro?
X
X                ----------
X
XHere's some useless test code that illustrates the problem:
X
X    lisp> (setq test_class (send Class :new '(a b c) '()))
X    lisp> (let (
X                (x 666)
X                (y 777)
X                (z 888))
X            (send test_class :answer :isnew '()  ;initialize method
X            '(
X           (setq a x)
X           (setq b y)
X           (setq c z)
X           ))
X            )
X    lisp> (setq i (send test_class :new))
X
XNow, upon sending the :new message, I get the error mesage
X
X    lisp> error: unbound variable - X
X
XAfter fixing the code in xlobj.c:clanswer(), I get the correct results:
X
X    lisp> (send i :show)
X    lisp> Object is #<Object: #136002>, Class is #<Object: #127f40>
X    lisp>   A = 666
X    lisp>   B = 777
X    lisp>   C = 888
X    lisp> #<Object: #136002>
X
X                ----------
X
XHere's the patch:
X
X*** xlobj.c.~1~    Sat Aug 26 06:14:33 1989
X--- xlobj.c    Sat Aug 26 06:16:24 1989
X***************
X*** 277,283
X      /* setup the message node */
X      xlprot1(fargs);
X      fargs = cons(s_self,fargs); /* add 'self' as the first argument */
X!     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL));
X      xlpop();
X
X      /* return the object */
X
X--- 277,283 -----
X      /* setup the message node */
X      xlprot1(fargs);
X      fargs = cons(s_self,fargs); /* add 'self' as the first argument */
X!     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,xlenv,xlfenv));    /* changed by NPM -- pass in lexical and functional environment */
X      xlpop();
X
X      /* return the object */
X
X-------------------------------------------------------------------------------
X        Niels Mayer -- hplabs!mayer -- [e-mail]
X          Human-Computer Interaction Department
X               Hewlett-Packard Laboratories
X                  Palo Alto, CA.
X                   *
X
X
SHAR_EOF
if test 3526 -ne "`wc -c 'xl-003.bug'`"
then
    echo shar: error transmitting "'xl-003.bug'" '(should have been 3526 characters)'
fi
echo shar: extracting "'xl-004.bug'" '(2058 characters)'
if test -f 'xl-004.bug'
then
    echo shar: over-writing existing file "'xl-004.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-004.bug'
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sun Sep 10 21:19:10 EDT 1989
XArticle: 148 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: save/restore bug fixes!
XMessage-ID: <[e-mail]>
XDate: 6 Sep 89 13:53:17 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 56
X
XOK, so it was pretty schlocky of me to mention my previous fix postings
Xrather than posting the fixes. I was just too busy to look them up.
X
XThere is no promise that these changes will fix the problem with xscheme,
Xbut there does seem to be numerous bugs that are in both x's.
X
XTom Almy
[e-mail]
X
X
X
X*******************
XProblem: "restore" corrupts system.
XDiagnosis: argument stack not being reset -- initial garbage collect
X "marks" random memory!
X
XSolution: Add to "initialize" in xlirestore:
X
X
X    xlfp = xlsp = xlargstkbase;
X    *xlsp++ = NIL;
X
X
X
X*******************
XProblem: "restore" corrupts system with 8086 compilers.
XDiagnosis: cvoptr is doing improper arithmetic.
X
XSolution: CVPTR in xlisp.h needs to be defined as
X#define CVPTR(x)    ((((unsigned long)(x) >> 16) << 4) + ((unsigned) x))
X
X    return statement in cvoptr() (xlimage.c) needs to be changed from:
Xreturn (off + (OFFTYPE)((p - seg->sg_nodes) << 1));
X    to:
Xreturn (off+(((CVPTR(p)-CVPTR(seg->sg_nodes))/sizeof(struct node))<<1));
X
X
XNote: for this to work with non-8086 compilers, the default for CVPTR
Xshould be changed from (x) to ((OFFTYPE)(x)).
X
X
X*******************
XA third problem that caused more than one restore in a session to fail had
Xbeen fixed already in xscheme.  For the record, though:
X
XBUG: Any attempt to do more than one RESTORE in a session causes the error
X    "insufficient memory - segment".
X
XIn file xlimage.c, function freeimage(), change
X
X        if (((fp = getfile(p)) != 0) && (fp != stdin && fp != stdout))
X
Xto:
X
X        if (((fp = getfile(p)) != 0) &&
X             (fp != stdin && fp != stdout && fp != stderr))
X
X
SHAR_EOF
if test 2058 -ne "`wc -c 'xl-004.bug'`"
then
    echo shar: error transmitting "'xl-004.bug'" '(should have been 2058 characters)'
fi
echo shar: extracting "'xl-005.bug'" '(3003 characters)'
if test -f 'xl-005.bug'
then
    echo shar: over-writing existing file "'xl-005.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-005.bug'
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Wed Jan 17 09:56:12 EST 1990
XArticle: 53 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: Some More bug fixes
XMessage-ID: <[e-mail]>
XDate: 15 Jan 90 18:27:05 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 134
X
XThese problems were pointed out to me by Paul van Niekerk
X([e-mail]). They are applicable to XLISP versions 2.0 or 2.1.
X
XPROBLEM: (last '(a b . c)) returns c rather than (b . c)
XSOLUTION: in xllist.c, replace xlast with:
X
X/* xlast - return the last cons of a list */
XLVAL xlast()
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* find the last cons */
X    if (consp(list))
X        while (consp(cdr(list))) list = cdr(list);
X
X    /* return the last element */
X    return (list);
X}
X
XPROBLEM: functions boundp, fboundp, symbol-name, symbol-value, and
Xsymbol-plist fail on NIL (which *is* a symbol), and symbol-function fails
Ximproperly (wrong error message).
X
XSOLUTION:
X
XIn xlisp.h, add:
X
X#define xlgasymornil()    (*xlargv==NIL || symbolp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
X
XIn xlbfun.c, change functions to the following:
X
X/* xboundp - is this a value bound to this symbol? */
XLVAL xboundp()
X{
X    LVAL sym;
X    sym = xlgasymornil();
X    xllastarg();
X    return (sym == NIL || boundp(sym) ? true : NIL);
X}
X
X/* xfboundp - is this a functional value bound to this symbol? */
XLVAL xfboundp()
X{
X    LVAL sym;
X    sym = xlgasymornil();
X    xllastarg();
X    return (sym != NIL && fboundp(sym) ? true : NIL);
X}
X
X/* xsymname - get the print name of a symbol */
XLVAL xsymname()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymornil();
X    xllastarg();
X
X    /* handle NIL, which is not internally represented as a symbol */
X    if (sym == NIL) {
X        sym = newstring(4);
X        strcpy(getstring(sym), "NIL");
X        return sym;
X    }
X
X    /* return the print name */
X    return (getpname(sym));
X}
X
X/* xsymvalue - get the value of a symbol */
XLVAL xsymvalue()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymornil();
X    xllastarg();
X
X    /* handle NIL */
X    if (sym == NIL) return (NIL);
X
X    /* get the global value */
X    while ((val = getvalue(sym)) == s_unbound)
X        xlunbound(sym);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymfunction - get the functional value of a symbol */
XLVAL xsymfunction()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymornil();
X    xllastarg();
X
X    /* handle NIL */
X    if (sym == NIL) {
X        while (1)
X            xlfunbound(sym);
X    }
X
X
X    /* get the global value */
X    while ((val = getfunction(sym)) == s_unbound)
X        xlfunbound(sym);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymplist - get the property list of a symbol */
XLVAL xsymplist()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymornil();
X    xllastarg();
X
X    /* return the property list */
X    return (sym == NIL ? NIL : getplist(sym));
X}
X
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X
SHAR_EOF
if test 3003 -ne "`wc -c 'xl-005.bug'`"
then
    echo shar: error transmitting "'xl-005.bug'" '(should have been 3003 characters)'
fi
echo shar: extracting "'xl-006.bug'" '(2689 characters)'
if test -f 'xl-006.bug'
then
    echo shar: over-writing existing file "'xl-006.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-006.bug'
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Thu Dec  7 08:52:22 EST 1989
XArticle: 42 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: More XLISP Bugs
XMessage-ID: <[e-mail]>
XDate: 4 Dec 89 18:18:34 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 110
X
X
X                                12/4/89
X
XI was trying some examples in Common Lisp: The Reference, and found some
Xbugs (both real and compatibility) in XLISP 2.0/2.1
X
X********************
X
XDouble quotes are not escaped when printing.
X(Fix needed in putqstring to handle case of '"').
X
Xchange:
X    if (ch < 040 || ch == '\\' || ch > 0176) {
Xto:
X    if (ch < 040 || ch == '\\' || ch == '"' || ch > 0176) {
X
Xchange:
X    case '\\':
X    xlputc(fptr,'\\');
X    break;
X
Xto:
X    case '\\':
X    case '"':
X    xlputc(fptr,ch);
X    break;
X
X******************
XIn version 2.1, #S() construct doesn't quote element values.
X":" not allowed on keywords, nor are the printed.
X
XExample:
X
X(defstruct foo (x 10))
X
X
X#S(foo)   prints #S(foo x 10) instead of #S(foo :x 10)
X
X#S(foo :x 10)  gives an error
X
X#S(foo x (+ 3 4)) gives #S(foo x 7) instead of #S(foo :x (+3 4))
X
XIn xlrdstruct() (xlstruct.c)
X
Xchange:
X    sprintf(buf,":%s",getstring(getpname(slotname)));
X
X    /* add the slot keyword */
X    rplacd(last,cons(xlenter(buf),NIL));
X
Xto:
X
X
X    /* add the slot keyword */
X    if (*(getstring(getpname(slotname))) != ':') { /* add colon */
X        sprintf(buf,":%s",getstring(getpname(slotname)));
X        rplacd(last,cons(xlenter(buf),NIL));
X    }
X    else {
X        rplacd(last,cons(slotname,NIL));
X    }
X
Xand change:
X    /* add the value expression */
X    rplacd(last,cons(car(list),NIL));
X    last = cdr(last);
X    list = cdr(list);
X
Xto:
X    /* add the value expression  -- QUOTED (TAA MOD) */
X    rplacd(last,cons(NIL,NIL));
X    last = cdr(last);
X    rplaca(last, (slotname = cons(s_quote,NIL)));
X    rplacd(slotname, cons(car(list), NIL));
X    list = cdr(list);
X
X
X
XIn xlprstruct(), replace:
X    xlputc(fptr,' ');
X
Xwith:
X    xlputstr(fptr," :");    /* TAA MOD, colons should show */
X
X****************
XIn XLISP 2.1, attempts to write to a structure element beyond the end of
Xthe structure (i.e. wrong access function used) tends to cause a crash.
X
XFIX: in both xstrref() and xstrset() (in xlstruct.c)
X
Xafter:
X    xllastarg();
X
Xadd:
X    if (i >= getsize(str)) /* wrong structure*/
X    xlerror("Bad structure reference",str);
X
X
X*********************
XI added #. macro, to eval at read time.
XTo switch statement in rmhash add:
X
X    case '.':
X        readone(fptr,&car(val));
X        rplaca(val,xleval(car(val)));
X        break;
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X
SHAR_EOF
if test 2689 -ne "`wc -c 'xl-006.bug'`"
then
    echo shar: error transmitting "'xl-006.bug'" '(should have been 2689 characters)'
fi
echo shar: extracting "'xl-cl001.fix'" '(41338 characters)'
if test -f 'xl-cl001.fix'
then
    echo shar: over-writing existing file "'xl-cl001.fix'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-cl001.fix'
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sat Sep 16 08:20:18 EDT 1989
XArticle: 1 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: XLISP 2.0 BUG(?)
XMessage-ID: <[e-mail]>
XDate: 11 Sep 89 14:34:11 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 22
X
X
XPart of my effort to make xlisp more compatible with Common Lisp:
X
XProblem: Functions which take the :end keyword argument do not allow NIL
X    to mean "end of list" as in Common Lisp.
X
XExample: (string-downcase "ABC DEF" :start 4 :end NIL) gives an error.
X
XFix: in function getbounds() in file xlstr.c, change
X
X    if (xlgkfixnum(ekey,&arg)) {
X        *pend = (int)getfixnum(arg);
X
Xto
X    if (xlgetkeyarg(ekey, &arg) && arg != NIL) {
X        if (!fixp(arg)) xlbadtype(arg);
X        *pend = (int)getfixnum(arg);
X
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sat Sep 16 08:20:26 EDT 1989
XArticle: 2 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: XLISP 2.0 Modifications (1 of 2)
XMessage-ID: <[e-mail]>
XDate: 11 Sep 89 22:25:11 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 393
X
XI have recently been adding a few Common Lisp functions to XLISP 2.0, and
Xmakeing some existing functions more Common-Lisp compatible (particularly
Xin making functions that are supposed to take sequence arguments (in XLISP
Xthat would be lists, arrays, or strings) actually take them.
X
XThese changes produce the following consequences:
X
X1.  Functions with names starting with "STRING" will accept a symbol as
X    the string argument.  The symbols printname string is used.
X
X2.  STRCAT is eliminated (a macro is placed in init.lsp for backwards
X    compatibility).  The replacement function is CONCATENATE which will
X    concatenate sequences of any type(s) into a result sequence of any
X    type.  It is used: (CONCATENATE <type> <seq1> [<seq2> ...]) where
X    type is the result type, one of CONS ARRAY or STRING.
X
X3.  AREF will work on strings as well as arrays.
X
X4.  SUBSEQ REVERSE REMOVE... DELETE... take sequence arguments rather
X    than just list arguments.
X
X5.  REMOVE... and DELETE... accept :start and :end keyword arguments.
X
X6.  Added function (ELT <seq> <index>) which combines the functionality
X    of AREF and NTH.
X
X7.  Added function (MAP <type> <fcn> <seq1> [<seq2> ...]) a mapping
X    function over sequences.  The resulting sequence is of type <type>,
X    which is one of CONS ARRAY STRING or NIL (meaning no, or NIL, result).
X
X8.  Added functions POSITION-IF, FIND-IF, and COUNT-IF, which work
X    analogously to REMOVE-IF, but return the position of the first match,
X    the first match, and number of matches, respectively.
X
X9.  Added function (SEARCH <seq1> <seq2> &key :test :test-not :start1
X    :end1 :start2 :end2) which returns the index of the first occurance
X    of seq1 in seq2. For example (search #(a b c) '(a b a b c d)) returns
X    2.
X
X10. Added function (COERCE <expr> <type>) which can coerce between
X    sequence types and in a limited basis to characters or floating point
X    numbers.
X
X
XThis is the first of two parts.  The final line in this file is "This is
Xthe end of part 1."
X
X
XTom Almy
XSeptember 11, 1989
[e-mail]
XStandard Disclaimers Apply
X
X
X***************************************
XThe first change reduces the amount of code.
X
XIn xlsubr.c, add the following definition:
X
X/* xlbadtype - report a "bad argument type" error */
XLVAL xlbadtype(arg)
X  LVAL arg;
X{
X    return xlerror("bad argument type",arg);
X}
X
X
XThen replace all occurances of `xlerror("bad argument type",' with
X`xlbadtype(' throughout the program (including xlisp.h).
X
X***************************************
X
XAdd the file xlseq.c to your "makefile" in an appropriate manner.
X
X***************************************
XAdd definition in xlisp.h:
X
X#define xlgastrorsym()  (testarg(symbolp(*xlargv) ? getpname(nextarg()) : typearg(stringp)))
X
XAdded external declaration in xlisp.h:
Xextern LVAL xlbadtype();        /* report "bad argument type" error */
X
X
X
X***************************************
XAdd to init.lsp:
X(unless (fboundp 'strcat) ; backwards compatibility
X    (defmacro strcat (&rest str) `(concatenate 'string ,@str)))
X
X
X
X***************************************
XIn xlftab.c, add the following external declaration:
Xextern LVAL
X    xcoerce(), xconcatenate(), xelt(), xmap(), xsearch(), xpositionif(),
X    xcountif(),xfindif();
X
Xdelete the declaration for xstrcat.
X
XIn funtab[], replace the definition for STRCAT with:
X
X{   "CONCATENATE",      S, xconcatenate }, /* 168 */
X
XReplace NULL definitions at the end of the table with new definitions,
Xbeing sure to keep the table length constant.
X
X{   "COUNT-IF",         S, xcountif     }, /* 287 */
X{   "FIND-IF",          S, xfindif      }, /* 288 */
X{   "COERCE",           S, xcoerce      }, /* 289 */
X{   "ELT",              S, xelt         }, /* 290 */
X{   "MAP",              S, xmap         }, /* 291 */
X{   "POSITION-IF",      S, xpositionif  }, /* 292 */
X{   "SEARCH",           S, xsearch      }, /* 293 */
X
X*******************************
X
XIn file xlglob.c, add the following definition:
X
XLVAL s_elt = NIL;
X
X*******************************
X
XIn file xlinit.c, add the following external declaration:
X
Xextern LVAL s_elt;
X
Xin function xlsymbols(), in section "enter setf place specifiers", add
X
X    s_elt   = xlenter("ELT");
X
X*******************************
X
XIn file xlbfun.c, function xaref(), change
X
X    array = xlgavector();
X
Xto
X
X    array = xlgetarg();
X
XBefore the section titled "range check the index" add:
X
X    if (stringp(array)) {   /* extension -- allow fetching chars from string*/
X        if (i < 0 || i >= getslength(array)-1)
X            xlerror("string index out of bounds",index);
X        return (cvchar(array->n_string[i]));
X    }
X
X    if (!vectorp(array)) xlbadtype(array);  /* type must be array */
X
X******************************
XIn xlcont.c, add the following declaration:
X
Xextern LVAL s_elt;
X
X
XIn function placeform(), replace the fun == s_aref code with:
X
X        xlsave1(arg1);
X
X        arg1 = evarg(&place);   /* allow string argument */
X        arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
X        if (place) toomany(place);
X
X        if (stringp(arg1)) {    /* extension for strings */
X            if (i < 0 || i >= getslength(arg1)-1)
X                xlerror("index out of range",arg2);
X            if (!charp(value))
X                xlerror("strings only contain characters",value);
X            arg1->n_string[i] = getchcode(value);
X        }
X        else if(vectorp(arg1)) {
X            if (i < 0 || i >= getsize(arg1))
X                xlerror("index out of range",arg2);
X            setelement(arg1,(int)i,value);
X        }
X        else xlbadtype(arg1);
X        xlpop();
X
XThen add the following "case":
X
X    else if (fun == s_elt) {
X        xlsave1(arg1);
X        arg1 = evarg(&place);
X        arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
X        if (place) toomany(place);
X        if (listp(arg1)) {
X            for (; i > 0 && consp(arg1); --i)
X                arg1 = cdr(arg1);
X            if((!consp(arg1)) || i < 0)
X                xlerror("index out of range",arg2);
X            rplaca(arg1,value);
X        }
X        else if (ntype(arg1) == STRING) {
X            if (i < 0 || i >= getslength(arg1)-1)
X                xlerror("index out of range",arg2);
X            if (!charp(value))
X                xlerror("strings only contain characters",value);
X            arg1->n_string[i] = getchcode(value);
X        }
X        else if (ntype(arg1) == VECTOR) {
X            if (i < 0 || i >= getsize(arg1))
X                xlerror("index out of range",arg2);
X            setelement(arg1,(int)i,value);
X        }
X        else xlbadtype(arg1);
X        xlpop();
X    }
X
X***************************
X
XIn xlstr.c, function changecase(), change
X
X    src = xlgastring();
X
Xto
X
X    src = (destructive? xlgastring() : xlgastrorsym());
X
X
XIn function strcompare(), change references to xlgastring to xlgastrorsym.
X
XIn function trim(), change references to xlgastring to xlgastrorsym.
X
X
XDelete functions xstrcat() and xsubseq().  The latter is rewritten and
Xwill be in a new file, xlseq.c
X
X****************************************
XIn file xlsys.c, add the following:
X
Xint xlcvttype(arg)  /* find type of argument and return it */
XLVAL arg;
X{
X    if (arg == a_subr)      return SUBR;
X    if (arg == a_fsubr)     return FSUBR;
X    if (arg == a_cons)      return CONS;
X    if (arg == a_symbol)    return SYMBOL;
X    if (arg == a_fixnum)    return FIXNUM;
X    if (arg == a_flonum)    return FLONUM;
X    if (arg == a_string)    return STRING;
X    if (arg == a_object)    return OBJECT;
X    if (arg == a_stream)    return STREAM;
X    if (arg == a_vector)    return VECTOR;
X    if (arg == a_closure)   return CLOSURE;
X    if (arg == a_char)      return CHAR;
X    if (arg == a_ustream)   return USTREAM;
X    return 0;
X}
X
XLOCAL LVAL listify(arg) /* arg must be vector or string */
XLVAL arg;
X{
X    LVAL val;
X    int i;
X
X    xlsave1(val);
X
X    if (ntype(arg) == VECTOR) {
X        for (i = getsize(arg); i-- > 0; )
X            val = cons(getelement(arg,i),val);
X    }
X    else {  /* a string */
X        for (i = getslength(arg)-1; i-- > 0; )
X            val = cons(cvchar(arg->n_string[i]),val);
X    }
X
X    xlpop();
X    return (val);
X}
X
XLOCAL LVAL vectify(arg) /* arg must be string or cons */
XLVAL arg;
X{
X    LVAL val,temp;
X    int i,l;
X
X    if (ntype(arg) == STRING) {
X        l = getslength(arg)-1;
X        val = newvector(l);
X        for (i=0; i < l; i++) setelement(val,i,cvchar(arg->n_string[i]));
X    }
X    else {  /* a cons */
X        val = arg;
X        for (l = 0; consp(val); l++) val = cdr(val); /* get length */
X        val = newvector(l);
X        temp = arg;
X        for (i = 0; i < l; i++) {
X            setelement(val,i,car(temp));
X            temp = cdr(temp);
X        }
X    }
X        return val;
X}
X
X
XLOCAL LVAL stringify(arg)   /* arg must be vector or cons */
XLVAL arg;
X{
X    LVAL val,temp;
X    int i,l;
X
X    if (ntype(arg) == VECTOR) {
X        l = getsize(arg);
X        val = newstring(l+1);
X        for (i=0; i < l; i++) {
X            temp = getelement(arg,i);
X            if (ntype(temp) != CHAR) goto failed;
X            val->n_string[i] = getchcode(temp);
X        }
X        val->n_string[l] = 0;
X        return val;
X    }
X    else {  /* must be cons */
X        val = arg;
X        for (l = 0; consp(val); l++) {
X            if (ntype(car(val)) != CHAR) goto failed;
X            val = cdr(val); /* get length */
X        }
X
X        val = newstring(l+1);
X        temp = arg;
X        for (i = 0; i < l; i++) {
X            val->n_string[i] = getchcode(car(temp));
X            temp = cdr(temp);
X        }
X        val->n_string[l] = 0;
X        return val;
X    }
Xfailed:
X    xlerror("cannot make into string", arg);
X}
X
X
X
X/* coerce function */
XLVAL xcoerce()
X{
X    LVAL type, arg, temp;
X    int newtype,oldtype;
X
X    arg = xlgetarg();
X    type = xlgetarg();
X    xllastarg();
X
X    if ((newtype = xlcvttype(type)) == 0) goto badconvert;
X
X    oldtype = ntype(arg);
X    if (oldtype == newtype) return (arg);   /* easy case! */
X
X    switch (newtype) {
X        case CONS: if ((oldtype == STRING)|(oldtype == VECTOR))
X            return (listify(arg));
X            break;
X        case STRING: if ((oldtype == CONS)|(oldtype == VECTOR))
X            return (stringify(arg));
X            break;
X        case VECTOR: if ((oldtype == STRING) | (oldtype == CONS))
X            return (vectify(arg));
X            break;
X        case CHAR:
X            if (oldtype == FIXNUM) return cvchar((int)getfixnum(arg));
X            else if ((oldtype == STRING) && (getslength(arg) == 2))
X                return cvchar(arg->n_string[0]);
X            else if (oldtype == SYMBOL) {
X                temp = getpname(arg);
X                if (getslength(temp) == 2) return cvchar(temp->n_string[0]);
X            }
X            break;
X        case FLONUM:
X            if (oldtype == FIXNUM) return (cvflonum(1.0*(int)getfixnum(arg)));
X            break;
X    }
X
X
Xbadconvert:
X    xlerror("illegal coersion",arg);
X
X}
X
X
X******************************
X
XIn file xllist.c, delete the functions xreverse(), xremove(), remif(),
Xxremif(), xremifnot(), xdelete(), delif(), xdelif(), xdelifnot(), dotest1().
XThese functions will be in the new file xlseq.c.
X
XRemove any LOCAL atribute to function dotest2().
X
X
X******************************
X
XThis is the end of part 1.
X
X
XFrom sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma Sat Sep 16 08:20:33 EDT 1989
XArticle: 3 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!zephyr.ens.tek.com!tekcrl!tekgvs!toma
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: XLISP 2.0 MODIFICATIONS (2 of 2)
XMessage-ID: <[e-mail]>
XDate: 11 Sep 89 22:26:44 GMT
XReply-To: [e-mail] (Tom Almy)
XOrganization: Tektronix, Inc., Beaverton,  OR.
XLines: 1073
X
XThe remainder of the changes consists of the file xlseq.c.
X
X
XTom Almy
XSeptember 11, 1989
[e-mail]
XStandard Disclaimers Apply
X
X
X******************************
X
X/* xlseq.c - xlisp sequence functions */
X/*  Written by Thomas Almy, based on code:
X    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use   */
X
X#include "xlisp.h"
X
X/* external procedures */
Xextern int xlcvttype();
Xextern int xlgkfixnum();
Xextern int xlgetkeyarg();
X
X/* external variables */
Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
X
X
X/* Apologies from the author (Tom Almy):
X   :start and :end isn't quite Kosher in
X   that it doesn't always signal an error for out of range.
X   Fixing it up is left as an exercise for the reader.*/
X
X/* I desparately needed a "MAXINT" or "MAXLONG" constant, so I faked it*/
X
X/* Also, I found it convenient to use "goto" statements to handle non-local
X   loop exits and jumps to common error routines.  A purist might complain,
X   but I think the code is cleaner and easier to follow this way. */
X
X#define MAXSIZE 10000000L   /* a lie, but good enough */
X
XLOCAL VOID getseqbounds(start,end,length,startkey,endkey)
Xlong *start, *end, length;
XLVAL *startkey, *endkey;
X{
X    LVAL arg;
X
X    if (xlgkfixnum(*startkey,&arg)) {
X        *start = (long)getfixnum(arg);
X        if (*start < 0 || *start > length ) goto rangeError;
X    }
X    else *start = 0;
X
X    if (xlgetkeyarg(*endkey, &arg) && arg != NIL) {
X        if (!fixp(arg)) xlbadtype(arg);
X        *end = (long)getfixnum(arg);
X        if (*end < 0  || *end > length) goto rangeError;
X    }
X    else *end = length; /* we need a maxint value! */
X
X    if (*start <= *end)     return;
X    /* else there is a range error */
X
XrangeError:
X    xlerror("range error",arg);
X}
X
X
X
X/* dotest1 - call a test function with one argument */
X/* this function was in xllist.c */
Xint dotest1(arg,fun)
X  LVAL arg,fun;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)1));
X    pusharg(arg);
X    xlfp = newfp;
X
X    /* return the result of applying the test function */
X    return (xlapply(1) != NIL);
X
X}
X
X
X/* xelt - sequence reference function */
XLVAL xelt()
X{
X    LVAL seq,index;
X    FIXTYPE i;
X
X    /* get the sequence and the index */
X
X    seq = xlgetarg();
X
X    index = xlgafixnum(); i = getfixnum(index);
X    if (i < 0) goto badindex;
X
X    xllastarg();
X
X    if (listp(seq)) { /* do like nth, but check for in range */
X        /* find the ith element */
X        while (consp(seq)) {
X            if (i-- == 0) return (car(seq));
X            seq = cdr(seq);
X        }
X        goto badindex;  /* end of list reached first */
X    }
X
X
X    if (ntype(seq) == STRING) {
X        if (i >= getslength(seq)-1) goto badindex;
X        return (cvchar(seq->n_string[i]));
X    }
X
X    if (ntype(seq)!=VECTOR) xlbadtype(seq); /* type must be array */
X
X    /* range check the index */
X    if (i >= getsize(seq)) goto badindex;
X
X    /* return the array element */
X    return (getelement(seq,(int)i));
X
Xbadindex:
X    xlerror("index out of bounds",index);
X}
X
X
X/* xmap -- map function */
X
XLOCAL long getlength(seq)
XLVAL seq;
X{
X    long len;
X
X    if (seq == NIL) return 0;
X
X    switch (ntype(seq)) {
X        case STRING:
X            return (long)getslength(seq) - 1;
X        case VECTOR:
X            return (long)getsize(seq);
X        case CONS:
X            len = 0;
X            while (consp(seq)) {
X                len++;
X                seq = cdr(seq);
X            }
X            return len;
X        default:
X            xlbadtype(seq);
X            return (0); /* ha ha */
X        }
X}
X
X
XLVAL xmap()
X{
X    LVAL *newfp, fun, lists, val, last, x, y;
X    long len,temp;
X    int argc, typ, i;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(fun);
X    xlsave(lists);
X    xlsave(val);
X
X    /* get the type of resultant */
X    if ((last = xlgetarg()) == NIL) {   /* nothing is returned */
X        typ = 0;
X    }
X    else if ((typ = xlcvttype(last)) != CONS &&
X                typ != STRING && typ != VECTOR) {
X        xlerror("invalid result type", last);
X    }
X
X    /* get the function to apply and argument sequences */
X    fun = xlgetarg();
X    val = NIL;
X    lists = xlgetarg();
X    len = getlength(lists);
X    argc = 1;
X
X    /* build a list of argument lists */
X    for (lists = last = consa(lists); moreargs(); last = cdr(last)) {
X        val = xlgetarg();
X        if ((temp = getlength(val)) < len) len = temp;
X        argc++;
X        rplacd(last,(cons(val,NIL)));
X    }
X
X    /* initialize the result list */
X    switch (typ) {
X        case VECTOR: val = newvector(len); break;
X        case STRING: val = newstring(len+1); break;
X        default:    val = NIL; break;
X    }
X
X
X    /* loop through each of the argument lists */
X    for (i=0;i<len;i++) {
X
X        /* build an argument list from the sublists */
X        newfp = xlsp;
X        pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X        pusharg(fun);
X        pusharg(NIL);
X        for (x = lists; x != NIL ; x = cdr(x)) {
X            y = car(x);
X            switch (ntype(y)) {
X                case CONS:
X                    pusharg(car(y));
X                    rplaca(x,cdr(y));
X                    break;
X                case VECTOR:
X                    pusharg(getelement(y,i));
X                    break;
X                case STRING:
X                    pusharg(cvchar(y->n_string[i]));
X                    break;
X            }
X        }
X
X        /* apply the function to the arguments */
X        newfp[2] = cvfixnum((FIXTYPE)argc);
X        xlfp = newfp;
X        x = xlapply(argc);
X
X        switch (typ) {
X            case CONS:
X                y = consa(x);
X                if (val) rplacd(last,y);
X                else val = y;
X                last = y;
X                break;
X            case VECTOR:
X                setelement(val,i,x);
X                break;
X            case STRING:
X                if (!charp(x))
X                    xlerror("map function returned non-character",x);
X                val->n_string[i] = getchcode(x);
X                break;
X        }
X
X    }
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the last test expression value */
X    return (val);
X    }
X
X
X
X
X/* xconcatenate - concatenate a bunch of sequences */
X/* replaces (and extends) strcat, now a macro */
XLOCAL int calclength()
X{
X    LVAL tmp, *saveargv;
X    int saveargc;
X    int len;
X
X    /* save the argument list */
X    saveargv = xlargv;
X    saveargc = xlargc;
X
X    /* find the length of the new string or vector */
X    for (len = 0; moreargs(); ) {
X        tmp = xlgetarg();
X        len += getlength(tmp);
X        if (len < 0) xlerror("too long",tmp);
X    }
X
X    /* restore the argument list */
X    xlargv = saveargv;
X    xlargc = saveargc;
X
X    return len;
X}
X
X
XLOCAL LVAL cattostring()
X{
X    LVAL tmp,temp,val;
X    unsigned char *str;
X    int len,i;
X
X    /* find resulting length -- also validates argument types */
X    len = calclength();
X
X    /* create the result string */
X    val = newstring(len+1);
X    str = getstring(val);
X
X    /* combine the strings */
X    while (moreargs()) {
X        tmp = nextarg();
X        if (tmp != NIL) switch (ntype(tmp)) {
X            case STRING:
X                len = getslength(tmp)-1;
X                memcpy((char *)str, (char *)getstring(tmp), len);
X                str += len;
X                break;
X            case VECTOR:
X                len = getsize(tmp);
X                for (i = 0; i < len; i++) {
X                    temp = getelement(tmp,i);
X                    if (!charp(temp)) goto failed;
X                    *str++ = getchcode(temp);
X                }
X                break;
X            case CONS:
X                while (consp(tmp)) {
X                    temp = car(tmp);
X                    if (!charp(temp)) goto failed;
X                    *str++ = getchcode(temp);
X                    tmp = cdr(tmp);
X                }
X                break;
X        }
X    }
X
X    *str = 0;   /* delimit string (why, I don't know!) */
X
X    /* return the new string */
X    return (val);
X
Xfailed:
X    xlerror("cannot make into string", tmp);
X}
X
XLOCAL LVAL cattovector()
X{
X    LVAL tmp,val;
X    LVAL *vect;
X    int len,i;
X
X    /* find resulting length -- also validates argument types */
X    len = calclength();
X
X    /* create the result vector */
X    val = newvector(len);
X    vect = &val->n_vdata[0];
X
X    /* combine the vectors */
X    while (moreargs()) {
X        tmp = nextarg();
X        if (tmp != NIL) switch (ntype(tmp)) {
X            case VECTOR:
X                len = getsize(tmp);
X                memcpy(vect, &getelement(tmp,0), len*sizeof(LVAL));
X                vect += len;
X                break;
X            case STRING:
X                len = getslength(tmp)-1;
X                for (i = 0; i < len; i++) {
X                    *vect++ = cvchar(tmp->n_string[i]);
X                }
X                break;
X            case CONS:
X                while (consp(tmp)) {
X                    *vect++ = car(tmp);
X                    tmp = cdr(tmp);
X                }
X                break;
X        }
X    }
X
X    /* return the new vector */
X    return (val);
X}
X
XLOCAL LVAL cattocons()
X{
X    LVAL val,tmp,next,last=NIL;
X    int len,i;
X
X    xlsave1(val);       /* protect against GC */
X
X    /* combine the lists */
X    while (moreargs()) {
X        tmp = nextarg();
X        if (tmp != NIL) switch (ntype(tmp)) {
X            case CONS:
X                while (consp(tmp)) {
X                    next = consa(car(tmp));
X                    if (val) rplacd(last,next);
X                    else val = next;
X                    last = next;
X                    tmp = cdr(tmp);
X                }
X                break;
X            case VECTOR:
X                len = getsize(tmp);
X                for (i = 0; i<len; i++) {
X                    next = consa(getelement(tmp,i));
X                    if (val) rplacd(last,next);
X                    else val = next;
X                    last = next;
X                }
X                break;
X            case STRING:
X                len = getslength(tmp) - 1;
X                for (i = 0; i < len; i++) {
X                    next = consa(cvchar(tmp->n_string[i]));
X                    if (val) rplacd(last,next);
X                    else val = next;
X                    last = next;
X                }
X                break;
X            default:
X                xlbadtype(tmp); break; /* need default because no precheck*/
X        }
X    }
X
X    xlpop();
X
X    return (val);
X
X}
X
X
XLVAL xconcatenate()
X{
X    LVAL tmp;
X
X    switch (xlcvttype(tmp = xlgetarg())) {  /* target type of data */
X        case CONS:      return cattocons();
X        case STRING:    return cattostring();
X        case VECTOR:    return cattovector();
X        default:        xlerror("invalid result type", tmp);
X    }
X}
X
X/* xsubseq - return a subsequence -- new version */
X
XLVAL xsubseq()
X{
X    int start,end,len;
X    int srctype;
X    LVAL src,dst;
X    LVAL next,last=NIL;
X
X    /* get sequence */
X    src = xlgetarg();
X    if (listp(src)) srctype = CONS;
X    else srctype=ntype(src);
X
X
X    /* get length */
X    switch (srctype) {
X        case STRING:
X            len = getslength(src) - 1;
X            break;
X        case VECTOR:
X            len = getsize(src);
X            break;
X        case CONS:
X            dst = src;  /* use dst as temporary */
X            len = 0;
X            while (consp(dst)) {len++; dst = cdr(dst);}
X            break;
X        default:
X            xlbadtype(src);
X    }
X
X    /* get the starting position */
X    dst = xlgafixnum(); start = (int)getfixnum(dst);
X    if (start < 0 || start > len)
X        xlerror("sequence index out of bounds",dst);
X
X    /* get the ending position */
X    if (moreargs()) {
X        dst = xlgafixnum(); end = (int)getfixnum(dst);
X        if (end < 0 || end > len)
X            xlerror("sequence index out of bounds",dst);
X    }
X    else
X        end = len;
X    xllastarg();
X
X    len = end - start;
X
X    switch (srctype) {  /* do the subsequencing */
X        case STRING:
X            dst = newstring(len+1);
X            memcpy(getstring(dst), getstring(src)+start, len);
X            dst->n_string[len] = 0;
X            break;
X        case VECTOR:
X            dst = newvector(len);
X            memcpy(dst->n_vdata, &src->n_vdata[start], sizeof(LVAL)*len);
X            break;
X        case CONS:
X            xlsave1(dst);
X            while (start--) src = cdr(src);
X            while (len--) {
X                next = consa(car(src));
X                if (dst) rplacd(last,next);
X                else dst = next;
X                last = next;
X                src = cdr(src);
X            }
X            xlpop();
X            break;
X    }
X
X    /* return the substring */
X    return (dst);
X}
X
X
X/* xreverse - built-in function reverse -- new version */
XLVAL xreverse()
X{
X    LVAL seq,val;
X    int i,len;
X
X    /* get the sequence to reverse */
X    seq = xlgetarg();
X    xllastarg();
X
X    if (seq == NIL) return (NIL);   /* empty argument */
X
X    switch (ntype(seq)) {
X        case CONS:
X            /* protect pointer */
X            xlsave1(val);
X
X            /* append each element to the head of the result list */
X            for (val = NIL; consp(seq); seq = cdr(seq))
X                val = cons(car(seq),val);
X
X            /* restore the stack */
X            xlpop();
X            break;
X        case VECTOR:
X            len = getsize(seq);
X            val = newvector(len);
X            for (i = 0; i < len; i++)
X                setelement(val,i,getelement(seq,len-i-1));
X            break;
X        case STRING:
X            len = getslength(seq) - 1;
X            val = newstring(len+1);
X            for (i = 0; i < len; i++)
X                val->n_string[i] = seq->n_string[len-i-1];
X            val->n_string[len] = 0;
X            break;
X        default:
X            xlbadtype(seq); break;
X    }
X
X    /* return the sequence */
X    return (val);
X}
X
X
X/* remif - common code for 'remove', 'remove-if', and 'remove-if-not' */
XLOCAL LVAL remif(tresult,expr)
X  int tresult,expr;
X{
X    LVAL x,seq,fcn,val,last,next;
X    int i,j,l;
X    long start,end;
X
X    if (expr) {
X        /* get the expression to remove and the sequence */
X        x = xlgetarg();
X        seq = xlgetarg();
X        xltest(&fcn,&tresult);
X    }
X    else {
X        /* get the function and the sequence */
X        fcn = xlgetarg();
X        seq = xlgetarg();
X/*      xllastarg(); */
X    }
X
X    if (seq == NIL) return NIL;
X
X    getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlprotect(fcn);
X    xlsave(val);
X
X    /* remove matches */
X
X    switch (ntype(seq)) {
X        case CONS:
X            end -= start;   /* length */
X            for (; consp(seq); seq = cdr(seq)) {
X
X                /* check to see if this element should be deleted */
X                /* force copy if count, as specified by end, is exhausted */
X                if (start-- > 0 || end-- <= 0 ||
X                    (expr?dotest2(x,car(seq),fcn)
X                    :dotest1(car(seq),fcn)) != tresult) {
X                    next = consa(car(seq));
X                    if (val) rplacd(last,next);
X                    else val = next;
X                    last = next;
X                }
X            }
X            break;
X        case VECTOR:
X            val = newvector(l=getlength(seq));
X            for (i=j=0; i < l; i++) {
X                if (i < start || i >= end ||    /* copy if out of range */
X                    (expr?dotest2(x,getelement(seq,i),fcn)
X                    :dotest1(getelement(seq,i),fcn)) != tresult) {
X                    setelement(val,j++,getelement(seq,i));
X                }
X            }
X            if (l != j) { /* need new, shorter result -- too bad */
X                fcn = val; /* save value in protected cell */
X                val = newvector(j);
X                memcpy(val->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
X            }
X            break;
X        case STRING:
X            l = getslength(seq)-1;
X            val = newstring(l+1);
X            for (i=j=0; i < l; i++) {
X                if (i < start || i >= end ||    /* copy if out of range */
X                    (expr?dotest2(x,cvchar(seq->n_string[i]),fcn)
X                    :dotest1(cvchar(seq->n_string[i]),fcn)) != tresult) {
X                    val->n_string[j++] = seq->n_string[i];
X                }
X            }
X            if (l != j) { /* need new, shorter result -- too bad */
X                fcn = val; /* save value in protected cell */
X                val = newstring(j+1);
X                memcpy(val->n_string, fcn->n_string, j*sizeof(char));
X                val->n_string[j] = 0;
X            }
X            break;
X        default:
X            xlbadtype(seq); break;
X    }
X
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the updated sequence */
X    return (val);
X}
X
X/* xremif - built-in function 'remove-if' -- enhanced version */
XLVAL xremif()
X{
X    return (remif(TRUE,FALSE));
X}
X
X/* xremifnot - built-in function 'remove-if-not' -- enhanced version */
XLVAL xremifnot()
X{
X    return (remif(FALSE,FALSE));
X}
X
X/* xremove - built-in function 'remove' -- enhanced version */
X
XLVAL xremove()
X{
X    return (remif(TRUE,TRUE));
X}
X
X
X/* delif - common code for 'delete', 'delete-if', and 'delete-if-not' */
XLOCAL LVAL delif(tresult,expr)
X  int tresult,expr;
X{
X    LVAL x,seq,fcn,last,val;
X    int i,j,l;
X    long start,end;
X
X    if (expr) {
X        /* get the expression to delete and the sequence */
X        x = xlgetarg();
X        seq = xlgetarg();
X        xltest(&fcn,&tresult);
X    }
X    else {
X        /* get the function and the sequence */
X        fcn = xlgetarg();
X        seq = xlgetarg();
X/*      xllastarg(); */
X    }
X
X    if (seq == NIL) return NIL;
X
X    getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
X
X    /* protect a pointer */
X    xlstkcheck(1);
X    xlprotect(fcn);
X
X
X    /* delete matches */
X
X    switch (ntype(seq)) {
X        case CONS:
X            end -= start; /* gives length */
X            /* delete leading matches */
X            while (consp(seq)) {
X                if (start-- > 0 || (expr?dotest2(x,car(seq),fcn)
X                    :dotest1(car(seq),fcn)) != tresult)
X                    break;
X                seq = cdr(seq);
X            }
X            val = last = seq;
X
X            /* delete embedded matches */
X            if (consp(seq)) {
X
X                /* skip the first non-matching element */
X                seq = cdr(seq);
X
X                /* look for embedded matches */
X                while (consp(seq)) {
X
X                    /* check to see if this element should be deleted */
X                    if (start-- <= 0 && end-- > 0 &&
X                        (expr?dotest2(x,car(seq),fcn)
X                    :dotest1(car(seq),fcn)) == tresult)
X                        rplacd(last,cdr(seq));
X                    else
X                        last = seq;
X
X                    /* move to the next element */
X                    seq = cdr(seq);
X                }
X            }
X            break;
X        case VECTOR:
X            l = getlength(seq);
X            for (i=j=0; i < l; i++) {
X                if (i < start || i >= end ||    /* copy if out of range */
X                    (expr?dotest2(x,getelement(seq,i),fcn)
X                    :dotest1(getelement(seq,i),fcn)) != tresult) {
X                    if (i != j) setelement(seq,j,getelement(seq,i));
X                    j++;
X                }
X            }
X            if (l != j) { /* need new, shorter result -- too bad */
X                fcn = seq; /* save value in protected cell */
X                seq = newvector(j);
X                memcpy(seq->n_vdata, fcn->n_vdata, j*sizeof(LVAL));
X            }
X            val = seq;
X            break;
X        case STRING:
X            l = getslength(seq)-1;
X            for (i=j=0; i < l; i++) {
X                if (i < start || i >= end ||    /* copy if out of range */
X                    (expr?dotest2(x,cvchar(seq->n_string[i]),fcn)
X                    :dotest1(cvchar(seq->n_string[i]),fcn)) != tresult) {
X                    if (i != j) seq->n_string[j] = seq->n_string[i];
X                    j++;
X                }
X            }
X            if (l != j) { /* need new, shorter result -- too bad */
X                fcn = seq; /* save value in protected cell */
X                seq = newstring(j+1);
X                memcpy(seq->n_string, fcn->n_string, j*sizeof(char));
X                seq->n_string[j] = 0;
X            }
X            val = seq;
X            break;
X        default:
X            xlbadtype(seq); break;
X    }
X
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the updated sequence */
X    return (val);
X}
X
X/* xdelif - built-in function 'delete-if' -- enhanced version */
XLVAL xdelif()
X{
X    return (delif(TRUE,FALSE));
X}
X
X/* xdelifnot - built-in function 'delete-if-not' -- enhanced version */
XLVAL xdelifnot()
X{
X    return (delif(FALSE,FALSE));
X}
X
X/* xdelete - built-in function 'delete' -- enhanced version */
X
XLVAL xdelete()
X{
X    return (delif(TRUE,TRUE));
X}
X
X/* xcountif - built-in function 'count-if     TAA MOD addition */
XLVAL xcountif()
X{
X    FIXTYPE counter=0;
X    int i,l;
X    long start,end;
X    LVAL seq, fcn;
X
X
X    /* get the arguments */
X    fcn = xlgetarg();
X    seq = xlgetarg();
X/*  xllastarg(); */
X
X    if (seq == NIL) return (cvfixnum(0L));
X
X    getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
X
X    xlstkcheck(1);
X    xlprotect(fcn);
X
X    /* examine arg and count */
X    switch (ntype(seq)) {
X        case CONS:
X            end -= start;
X            for (; consp(seq); seq = cdr(seq))
X                if (start-- <= 0 && end-- > 0 &&
X                    dotest1(car(seq),fcn)) counter++;
X            break;
X        case VECTOR:
X            l = getlength(seq);
X            if (end < l) l = end;
X            for (i=start; i < l; i++)
X                if (dotest1(getelement(seq,i),fcn)) counter++;
X            break;
X        case STRING:
X            l = getslength(seq)-1;
X            if (end < l) l = end;
X            for (i=start; i < l; i++)
X                if (dotest1(cvchar(seq->n_string[i]),fcn)) counter++;
X            break;
X        default:
X            xlbadtype(seq); break;
X    }
X
X    xlpop();
X
X    return (cvfixnum(counter));
X}
X
X/* xfindif - built-in function 'find-if'    TAA MOD */
XLVAL xfindif()
X{
X    LVAL seq, fcn, val;
X    long start,end;
X    int i,l;
X
X    fcn = xlgetarg();
X    seq = xlgetarg();
X/*  xllastarg(); */
X
X    if (seq == NIL) return NIL;
X
X    getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
X
X    xlstkcheck(1);
X    xlprotect(fcn);
X
X    switch (ntype(seq)) {
X        case CONS:
X            end -= start;
X            for (; consp(seq); seq = cdr(seq)) {
X                if (start-- <= 0 && end-- > 0 &&
X                    dotest1(val=car(seq), fcn)) goto fin;
X            }
X            break;
X        case VECTOR:
X            l = getlength(seq);
X            if (end < l) l = end;
X            for (i=start; i < l; i++)
X                if (dotest1(val=getelement(seq,i),fcn)) goto fin;
X            break;
X        case STRING:
X            l = getslength(seq)-1;
X            if (end < l) l = end;
X            for (i=start; i < l; i++)
X                if (dotest1(val=cvchar(seq->n_string[i]),fcn)) goto fin;
X            break;
X        default:
X            xlbadtype(seq); break;
X    }
X
X    val = NIL;  /* not found */
X
Xfin:
X    xlpop();
X    return (val);
X}
X
X/* xpositionif - built-in function 'position-if'    TAA MOD */
XLVAL xpositionif()
X{
X    LVAL seq, fcn;
X    long start,end;
X    FIXTYPE count;
X    int i,l;
X
X    fcn = xlgetarg();
X    seq = xlgetarg();
X/*  xllastarg(); */
X
X    if (seq == NIL) return NIL;
X
X    getseqbounds(&start,&end,MAXSIZE,&k_start,&k_end);
X
X    xlstkcheck(1);
X    xlprotect(fcn);
X
X    switch (ntype(seq)) {
X        case CONS:
X            end -= start;
X            count = 0;
X            for (; consp(seq); seq = cdr(seq)) {
X                if ((start-- <= 0) && (end-- > 0) &&
X                    dotest1(car(seq), fcn)) goto fin;
X                count++;
X            }
X            break;
X        case VECTOR:
X            l = getlength(seq);
X            if (end < l) l = end;
X            for (i=start; i < l; i++)
X                if (dotest1(getelement(seq,i),fcn)) {
X                    count = i;
X                    goto fin;
X                }
X            break;
X        case STRING:
X            l = getslength(seq)-1;
X            if (end < l) l = end;
X            for (i=start; i < l; i++)
X                if (dotest1(cvchar(seq->n_string[i]),fcn)) {
X                    count = i;
X                    goto fin;
X                }
X            break;
X        default:
X            xlbadtype(seq); break;
X    }
X
X    xlpop();    /* not found */
X    return(NIL);
X
Xfin:            /* found */
X    xlpop();
X    return (cvfixnum(count));
X}
X
X/* xsearch -- search function */
X
XLVAL xsearch()
X{
X    LVAL seq1, seq2, fcn, temp1, temp2;
X    long start1, start2, end1, end2, len1, len2;
X    long i,j;
X    int tresult,typ1, typ2;
X
X    /* get the sequences */
X    seq1 = xlgetarg();
X    len1 = getlength(seq1);
X    seq2 = xlgetarg();
X    len2 = getlength(seq2);
X
X    /* test/test-not args? */
X    xltest(&fcn,&tresult);
X
X    /* check for start/end keys */
X    getseqbounds(&start1,&end1,len1,&k_1start,&k_1end);
X    getseqbounds(&start2,&end2,len2,&k_2start,&k_2end);
X
X    if (end2 - 1 + (start1 - end1) > len2) {
X        end2 = len2 + 1 - (start1 - end1);
X        if (end2 < start2) end2 = start2;
X    }
X
X    len1 = end1 - start1;   /* calc lengths of sequences to test */
X
X    typ1 = ntype(seq1);
X    typ2 = ntype(seq2);
X
X    xlstkcheck(1);
X    xlprotect(fcn);
X
X    if (typ1 == CONS) { /* skip leading section of sequence 1 if a cons */
X        j = start1;
X        while (j--) seq1 = cdr(seq1);
X    }
X
X    if (typ2 == CONS) { /* second string is cons */
X        i = start2;     /* skip leading section of string 2 */
X        while (start2--) seq2 = cdr(seq2);
X
X        for (;i<end2;i++) {
X            temp2 = seq2;
X            if (typ1 == CONS) {
X                temp1 = seq1;
X                for (j = start1; j < end1; j++) {
X                    if (dotest2(car(temp1),car(temp2),fcn) != tresult)
X                        goto next1;
X                    temp1 = cdr(temp1);
X                    temp2 = cdr(temp2);
X                }
X            }
X            else {
X                for (j = start1; j < end1; j++) {
X                    if (dotest2(typ1 == VECTOR ? getelement(seq1,j)
X                                               : cvchar(seq1->n_string[j]),
X                        car(temp2), fcn) != tresult)
X                        goto next1;
X                    temp2 = cdr(temp2);
X                }
X            }
X            xlpop();
X            return cvfixnum(i);
X            next1: /* continue */
X            seq2 = cdr(seq2);
X        }
X    }
X
X    else for (i = start2; i < end2 ; i++) { /* second string is array/string */
X        if (typ1 == CONS) {
X            temp1 = seq1;
X            for (j = 0; j < len1; j++) {
X                if (dotest2(car(temp1),
X                            typ2 == VECTOR ? getelement(seq2,i+j)
X                                           : cvchar(seq2->n_string[i+j]),
X                            fcn) != tresult)
X                    goto next2;
X                temp1 = cdr(temp1);
X            }
X        }
X        else for (j=start1; j < end1; j++) {
X            if (dotest2(typ1 == VECTOR ? getelement(seq1,j)
X                                       : cvchar(seq1->n_string[j]),
X                typ2 == VECTOR ? getelement(seq2,i+j-start1)
X                               : cvchar(seq2->n_string[i+j-start1]),
X                fcn) != tresult)
X                    goto next2;
X        }
X        xlpop();
X        return cvfixnum(i);
X        next2:; /* continue */
X    }
X
X    xlpop();
X    return (NIL);   /*no match*/
X
X}
X
X
XEND OF PART 2
X
X
SHAR_EOF
if test 41338 -ne "`wc -c 'xl-cl001.fix'`"
then
    echo shar: error transmitting "'xl-cl001.fix'" '(should have been 41338 characters)'
fi
echo shar: extracting "'xl-xs001.bug'" '(2766 characters)'
if test -f 'xl-xs001.bug'
then
    echo shar: over-writing existing file "'xl-xs001.bug'"
fi
sed 's/^X//' << \SHAR_EOF > 'xl-xs001.bug'
XFrom sce!mitel!uunet!mcvax!kth!draken!liuida!mikpe Fri Apr 14 14:35:35 EDT 1989
XArticle: 85 of comp.lang.lisp.x
XPath: cognos!sce!mitel!uunet!mcvax!kth!draken!liuida!mikpe
XFrom: [e-mail] (Mikael Pettersson)
XNewsgroups: comp.lang.lisp.x
XSubject: X{scheme,lisp} bugs
XSummary: operating on closed files can cause NULL dereferences
XMessage-ID: <[e-mail]>
XDate: 13 Apr 89 04:13:07 GMT
XOrganization: CIS Dept, Univ of Linkoping, Sweden
XLines: 61
X
X
XI stumbled across a bug in Xscheme's handling of ports. It turns out
Xthat none of the functions that take ports as arguments check whether
Xthe port is open (i.e. it hasn't been closed) (except xclose() itself!).
XSending a closed port to e.g. READ causes a NULL dereference down in
Xthe OS specific stuff: on my UNIX machine Xscheme dies with a SIGSEGV.
XThe easiest fix (although it has the side-effect of making PORT? return #F
Xfor closed ports) is to change the portp() macro in xscheme.h like this:
X
X*** xscheme.h.~1~    Sun Feb 19 13:25:29 1989
X--- xscheme.h    Wed Apr 12 18:41:26 1989
X***************
X*** 207,213 ****
X  #define consp(x)    ((x) && ntype(x) == CONS)
X  #define stringp(x)    ((x) && ntype(x) == STRING)
X  #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
X! #define portp(x)    ((x) && ntype(x) == PORT)
X  #define objectp(x)    ((x) && ntype(x) == OBJECT)
X  #define fixp(x)        ((x) && ntype(x) == FIXNUM)
X  #define floatp(x)    ((x) && ntype(x) == FLONUM)
X--- 207,213 ----
X  #define consp(x)    ((x) && ntype(x) == CONS)
X  #define stringp(x)    ((x) && ntype(x) == STRING)
X  #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
X! #define portp(x)    ((x) && ntype(x) == PORT && getfile(x))
X  #define objectp(x)    ((x) && ntype(x) == OBJECT)
X  #define fixp(x)        ((x) && ntype(x) == FIXNUM)
X  #define floatp(x)    ((x) && ntype(x) == FLONUM)
X
X
XI then went to see if Xlisp was equally fragile, but luckily it wasn't.
XOnly xformat() (due to it's checking for NIL, T and unnamed streams)
Xmisses to check that the file is open.
XThe following patch fixes that problem (your line numbers may vary):
X
X*** xlfio.c.~1~    Mon Dec 19 06:07:30 1988
X--- xlfio.c    Wed Apr 12 20:35:40 1989
X***************
X*** 410,416 ****
X      else {
X      if (stream == true)
X          stream = getvalue(s_stdout);
X!     else if (!streamp(stream) && !ustreamp(stream))
X          xlbadtype(stream);
X      val = NIL;
X      }
X--- 410,420 ----
X      else {
X      if (stream == true)
X          stream = getvalue(s_stdout);
X!     else if (streamp(stream)) {    /* copied from xlgetfile() */
X!         if (getfile(stream) == NULL)
X!         xlfail("file not open");
X!     }
X!     else if (!ustreamp(stream))
X          xlbadtype(stream);
X      val = NIL;
X      }
X--
XMikael Pettersson, Dept of Comp & Info Sci, University of Linkoping, Sweden
Xemail: [e-mail]  or  ..!{mcvax,munnari,uunet}!enea!liuida!mpe
X
X
SHAR_EOF
if test 2766 -ne "`wc -c 'xl-xs001.bug'`"
then
    echo shar: error transmitting "'xl-xs001.bug'" '(should have been 2766 characters)'
fi
#    End of shell archive
exit 0
--
Gary Murphy                   uunet!mitel!sce!cognos!garym
                              ([e-mail])
[phone] x5537          Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc